home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FPCDOCS.LZH / KERNEL3.SEQ < prev    next >
Text File  |  1988-09-20  |  22KB  |  637 lines
  1. \ KERNEL3.SEQ   More kernel stuff
  2.  
  3. FILES DEFINITIONS
  4.  
  5. VARIABLE KERNEL3.SEQ
  6.  
  7. FORTH DEFINITIONS
  8.  
  9. : >TYPE         ( adr len -- )
  10.                 TUCK PAD SWAP CMOVE   PAD SWAP TYPE  ;
  11.  
  12. : .(            ( -- )  ASCII ) PARSE >TYPE  ; IMMEDIATE
  13.  
  14. : (             ( -- )  ASCII ) PARSE 2DROP  ; IMMEDIATE
  15.  
  16. CODE TRAVERSE   ( addr direction -- addr' )
  17.                 POP CX          POP BX
  18.                 ADD BX, CX      PUSH ES
  19.                 MOV ES, YSEG
  20.           BEGIN
  21.                 MOV ES: AL, 0 [BX]      AND AL, # 128
  22.        0= WHILE
  23.                 ADD BX, CX
  24.           REPEAT
  25.                 POP ES          PUSH BX
  26.                 NEXT            END-CODE
  27.  
  28. CODE DONE?      ( n -- f )
  29.                 POP AX
  30.                 CMP AX, STATE
  31.             0<> IF
  32.                         MOV END? # 0 WORD
  33.                         MOV AX, # -1
  34.                         1PUSH
  35.                 THEN
  36.                 PUSH END?
  37.                 MOV END? # 0 WORD
  38.                 NEXT
  39.                 END-CODE
  40.  
  41. \ : DONE?         ( n -- f )
  42. \                 STATE @ <>   END? @ OR   END? OFF   ;
  43.  
  44. : CNHASH        ( CFA-YA )
  45.                 $0FE00 AND FLIP ;
  46.  
  47. CODE CNSRCH     ( CFA YA MAXYA - NFA failf )
  48.                 pop dx          \ maxya
  49.                 pop bx          \ ya
  50.                 add bx, # 4
  51.                 pop di          \ cfa
  52.                 mov ds, yseg
  53.         HERE    cmp dx, bx
  54.              U> IF      mov ax, 0 [bx]
  55.                         and ax, # 31
  56.                         add bx, ax
  57.                         inc bx
  58.                         mov ax, 0 [bx]
  59.                         cmp ax, di      \ if they match, then we found it
  60.                      0= if      sub bx, # 2             \ 1 before last chr
  61.                                 begin   mov al, 0 [bx]  \ test high bit
  62.                                         and al, # 128   \ loop till high set
  63.                              0= while   dec bx          \ backup one char
  64.                                 repeat
  65.                                 push bx                 \ push pointer to chr
  66.                                 mov ax, cs              \ restore DS
  67.                                 mov ds, ax
  68.                                 mov ax, # false         \ push false flag
  69.                                 1push
  70.                         then
  71.                         add bx, # 6     \ step to next header
  72.                         JMP ROT         \ bring HERE around Branch resolution
  73.                                         \ used by IF and THEN
  74.                 THEN
  75.                 mov ax, cs      mov ds, ax
  76.                 mov ax, # true
  77.                 push ax
  78.                 1push           end-code
  79.  
  80. : N>LINK        2-   ;
  81. : L>NAME        2+   ;
  82. : BODY>         3 -  ;
  83.  
  84. : NAME>         1 TRAVERSE   1+ Y@  ;
  85. : LINK>         L>NAME   NAME>   ;
  86. : >BODY         3 +  ;
  87.  
  88. HERE-Y 4 +     \ Step from view field to name field
  89.  
  90. : NO-NAME ;
  91.  
  92. : >NAME         ( cfa - nfa )
  93.                 DUP CNHASH DUP Y@ SWAP
  94.                 2+ Y@ ( cfa sya mxya ) CNSRCH
  95.                 IF      DROP (LIT) [ ROT ,-X ] THEN    ;
  96.  
  97. : >LINK         >NAME   N>LINK   ;
  98. : >VIEW         >LINK   2-   ;
  99. : VIEW>         2+   LINK>   ;
  100.  
  101. COMMENT:
  102.  
  103.   The hash algorithm used is as follows:
  104.  
  105.         ((firstchar*2)+secondchar)*2)+count
  106.  
  107.   This seems to provide a good distribution across the 64 threads in
  108. 1000 word FORTH vocabulary.
  109.  
  110. COMMENT;
  111.  
  112. CODE HASH       ( str-addr voc-ptr -- thread )
  113.                 POP CX          POP BX
  114.                 MOV AX, 1 [BX]          \ Get first and second chars
  115.                 SHL AL, # 1             \ Shift first char left one
  116.                 ADD AL, AH              \ Plus second char
  117.                 SHL AX, # 1             \ The sum shifted left one again
  118.                 ADD AL, 0 [BX]          \ Plus count byte
  119.                 AND AX, # #THREADS 1-
  120.                 SHL AX, # 1     ADD AX, CX
  121.                 1PUSH           END-CODE
  122.  
  123. CODE (FIND)     ( here alf -- cfa flag | here false )
  124.                 POP BX
  125. LABEL (FIND)1   OR BX, BX
  126.              0= IF
  127.                         SUB AX, AX
  128.                         1PUSH
  129.                 THEN
  130.                 POP CX
  131.                 PUSH ES
  132.                 MOV ES, YSEG
  133.                 MOV DI, CX
  134.             BEGIN
  135.                 MOV ES: AX, 2 [BX]
  136.                 XOR AX, 0 [DI]
  137.                 AND AX, # ( 63 ) $7F3F
  138.              0= IF
  139.                         MOV DX, BX
  140.                         ADD BX, # 2
  141.                         BEGIN
  142.                                 INC BX  INC DI
  143.                                 MOV ES: AL, 0 [BX]
  144.                                 XOR AL, 0 [DI]
  145.                     0<> UNTIL
  146.                         AND AL, # 127
  147.                      0= IF
  148.                                 MOV ES: CX, 1 [BX]      \ pick up CFA
  149.                                 MOV BX, DX
  150.                                 MOV ES: AL, 2 [BX]
  151.                                 AND AL, # 64
  152.                                 0<> IF
  153.                                     MOV AX, # 1
  154.                                 ELSE
  155.                                     MOV AX, # -1
  156.                                 THEN
  157.                                 POP ES
  158.                                 PUSH CX
  159.                                 1PUSH
  160.                         THEN
  161.                         MOV BX, DX
  162.                         MOV DI, CX
  163.                 THEN
  164.                 MOV ES: BX, 0 [BX]
  165.                 OR BX, BX
  166.         0= UNTIL
  167.                 POP ES
  168.                 PUSH CX
  169.                 SUB AX, AX
  170.                 1PUSH           END-CODE
  171.  
  172. CODE DROP.CONTEXT.I2*+@DUP   ( A1 --- N1 )
  173.                 ADD SP, # 2
  174.                 MOV AX, 0 [RP]
  175.                 ADD AX, 2 [RP]
  176.                 SHL AX, # 1
  177.                 MOV BX, # CONTEXT
  178.                 ADD BX, AX
  179.                 MOV AX, 0 [BX]
  180.                 PUSH AX
  181.                 1PUSH
  182.                 END-CODE
  183.  
  184.                                 \ DUP PRIOR @ OVER PRIOR ! =
  185. CODE PRIOR.CHECK ( N1 --- N1 F1 )
  186.                 POP AX
  187.                 PUSH AX
  188.                 MOV BX, PRIOR
  189.                 MOV PRIOR AX
  190.                 CMP BX, AX
  191.             0<> IF
  192.                         MOV AX, # FALSE
  193.                         1PUSH
  194.                 THEN
  195.                 MOV AX, # TRUE
  196.                 1PUSH
  197.                 END-CODE
  198.  
  199. CODE OVER.SWAP.HASH.@(FIND)
  200.                 POP AX
  201.                 POP BX
  202.                 PUSH BX
  203.                 MOV CL, 0 [BX]
  204.                 MOV BX, 1 [BX]
  205.                 SHL BL, # 1
  206.                 ADD BL, BH
  207.                 SHL BL, # 1
  208.                 ADD BL, CL
  209.                 AND BX, # #THREADS 1-
  210.                 SHL BX, # 1
  211.                 ADD BX, AX
  212.                 MOV BX, 0 [BX]
  213.                 JMP (FIND)1
  214. \                PUSH 0 [BX]
  215. \                NEXT
  216.                 END-CODE
  217.  
  218. : FIND          ( addr -- cfa flag | addr false )
  219.                 DUP C@
  220.                 IF      \ PRIOR OFF   FALSE   #VOCS 0
  221.                         [ INLINE
  222.                                 MOV PRIOR # 0
  223.                                 MOV AX, # 0
  224.                                 PUSH AX
  225.                                 MOV DX, # #VOCS
  226.                                 2PUSH           END-INLINE ]
  227.                         DO      DROP.CONTEXT.I2*+@DUP
  228.                                 IF      PRIOR.CHECK
  229.                                         IF      DROP FALSE
  230.                                         ELSE    OVER.SWAP.HASH.@(FIND)
  231.                                                 DUP ?LEAVE
  232.                                         THEN
  233.                                 THEN
  234.                         LOOP
  235.                 ELSE    DROP END? ON  ['] NOOP 1
  236.                 THEN    ;
  237.  
  238. : DEFINED       ( -- here 0 | cfa [ -1 | 1 ] )
  239.                 BL WORD  ?UPPERCASE  FIND   ;
  240.  
  241. : STACKUNDER    ( --- )
  242.                 TRUE ABORT" Stack Underflow" ;
  243.  
  244. : STACKOVER     ( --- )
  245.                 TRUE ABORT" Stack Overflow" ;
  246.  
  247. : WARNOVER      ( --- )
  248.                 CR ."  Running out of CODE memory! " ;
  249.  
  250. CODE (?STACK)   ( --- )
  251.                 MOV CX, SP
  252.                 MOV BX, UP
  253.                 MOV DX, SP0 [BX]
  254.                 CMP DX, CX
  255.              U< IF
  256.                         MOV AX, # ' STACKUNDER
  257.                         JMP AX
  258.                 THEN
  259.                 MOV DX, DP [BX]
  260.                 ADD DX, # 80
  261.                 CMP CX, DX
  262.              U< IF
  263.                         MOV AX, # ' STACKOVER
  264.                         JMP AX
  265.                 THEN
  266.                 ADD DX, # 200
  267.                 CMP CX, DX
  268.              U< IF
  269.                         MOV AX, # ' WARNOVER
  270.                         JMP AX
  271.                 THEN
  272.                 NEXT            END-CODE
  273.  
  274. DEFER ?STACK    ' (?STACK) IS ?STACK
  275.  
  276. : INTERP        ( -- )
  277.                 BEGIN   ?STACK DEFINED
  278.                         IF     EXECUTE
  279.                         ELSE   NUMBER  DOUBLE? NOT IF  DROP  THEN
  280.                         THEN   FALSE DONE?
  281.                 UNTIL   ;
  282.  
  283. DEFER STATUS    ( -- )
  284.  
  285. DEFER INTERPRET ' INTERP IS INTERPRET
  286.  
  287. : PRINT         ( --- ) PRINTING ON INTERPRET PRINTING OFF ;
  288.  
  289. : ALLOT         ( n -- )      DP +!   ;
  290.  
  291. CODE ,          ( N --- )
  292.                 MOV BX, UP
  293.                 MOV AX, DP [BX]
  294.                 ADD DP [BX], # 2 WORD
  295.                 MOV BX, AX
  296.                 POP CX
  297.                 MOV 0 [BX], CX
  298.                 NEXT
  299.                 END-CODE
  300.  
  301. CODE C,         ( N --- )
  302.                 MOV BX, UP
  303.                 MOV AX, DP [BX]
  304.                 INC DP [BX] WORD
  305.                 MOV BX, AX
  306.                 POP CX
  307.                 MOV 0 [BX], CL
  308.                 NEXT
  309.                 END-CODE
  310.  
  311. : PARAGRAPH     ( OFFSET --- PARAGRAPH-INC ) 15 + U16/ ;
  312. : ALIGN         ( HERE 1 AND IF  BL C,  THEN )  ; IMMEDIATE
  313. : EVEN          ( DUP 1 AND + ) ;  IMMEDIATE
  314. : COMPILE       ( -- )   2R@ R> 2+ >R @L X,   ;
  315. : CCOMPILE      ( -- )   2R@ R> 2+ >R @L  ,   ;
  316. : IMMEDIATE     ( -- )   64 ( Precedence bit ) LAST @ YCSET  ;
  317. : LITERAL       ( n -- )  COMPILE (LIT) X, ; IMMEDIATE
  318. : DLITERAL      ( d# -- ) SWAP [COMPILE] LITERAL [COMPILE] LITERAL ; IMMEDIATE
  319.  
  320. : ASCII         ( -- n )   BL WORD   1+ C@
  321.                 STATE @ IF   [COMPILE] LITERAL   THEN   ; IMMEDIATE
  322.  
  323. : CONTROL       ( -- n )   BL WORD   1+ C@  31 AND
  324.                 STATE @ IF   [COMPILE] LITERAL   THEN   ; IMMEDIATE
  325.  
  326. : CRASH         ( -- ) 2R@ 2- @L >NAME CR .ID TRUE
  327.                 ABORT" <- is an Uninitialized execution vector."  ;
  328.  
  329. : ?MISSING      ( f -- )
  330.                 IF      SPACE 'WORD COUNT TYPE
  331.                         TRUE ABORT"  <- What? "
  332.                 THEN    ;
  333.  
  334. : '             ( -- cfa )      DEFINED 0= ?MISSING   ;
  335.  
  336. : [']           ( -- )          ' [COMPILE] LITERAL   ; IMMEDIATE
  337. : [COMPILE]     ( -- )          ' X,   ; IMMEDIATE
  338.  
  339. VARIABLE  "BUF 80 ALLOT
  340.  
  341. : XEVEN         ( XDP --- XDP_EVEN ) DUP 1 AND + ;
  342.  
  343. : XALIGN        ( --- ) XHERE NIP 1 AND XDP +! ;
  344.  
  345. : X>"BUF        ( --- "BUF )
  346.                 2R>
  347.                 2R@ 2DUP C@L 1+ DUP XEVEN R> + >R
  348.                         ?CS: "BUF ROT CMOVEL
  349.                 2>R "BUF ;
  350.  
  351. : (")           ( -- addr len )
  352.                 2R@ @L COUNT R> 2+ >R ;
  353.  
  354. : (X")           ( -- addr len )
  355.                 X>"BUF COUNT ;
  356.  
  357. : (.")          ( -- )
  358.                 2R@ 2DUP C@L >R 1+ R@ EXTYPE R> 1+ XEVEN R> + >R ;
  359.  
  360. : ,"            ( --- )
  361.                 ASCII " PARSE TUCK 'WORD PLACE 1+ ALLOT ;
  362.  
  363. : X,"           ( -- )
  364.                 ASCII " PARSE 'WORD PLACE
  365.                 ?CS: 'WORD DUP C@ 1+ >R XHERE R@ CMOVEL
  366.                 R> XEVEN XDP +! ;
  367.  
  368. : ."            ( -- )          COMPILE (.") X,"   ;   IMMEDIATE
  369.  
  370. : "             ( -- )          COMPILE (")  HERE X, ,"   ;   IMMEDIATE
  371.  
  372. : ""            ( -- )          COMPILE (X")  X,"   ;   IMMEDIATE
  373.  
  374. : ">$           ( A1 -- A2 )    DROP 1- ;
  375.  
  376. VARIABLE FENCE
  377.  
  378. : TRIM          ( faddr voc-addr -- )
  379.                 #THREADS 0
  380.                 DO      2DUP @ BEGIN   2DUP U> NOT WHILE Y@ REPEAT
  381.                         NIP OVER ! 2+
  382.                 LOOP    2DROP   ;
  383.  
  384. : (FRGET)       ( code-addr view-addr -- )
  385.                 DUP FENCE @ U< ABORT" Below fence"  ( ca va )
  386.                 OVER VOC-LINK @ BEGIN   2DUP U< WHILE   @ REPEAT
  387.                 DUP VOC-LINK !  ( ca va ca pt ) NIP
  388.                 BEGIN   DUP WHILE   2DUP #THREADS 2* - TRIM   @   REPEAT
  389.                 DROP    YDP !
  390.                 DUP 1+ @ OVER >BODY +
  391.                 (LIT)   TRIM DUP 1+ @ SWAP >BODY + =    \ If it's a : def
  392.                 IF      DUP >BODY @ XSEG @ + XDPSEG !   \ Set back XHERE too!
  393.                         XDP OFF
  394.                 THEN    DP !  ;
  395.  
  396. DEFER WHERE
  397. DEFER ?ERROR
  398.  
  399. : (ABORT")      ( f -- )
  400.                 X>"BUF COUNT ROT ?ERROR ;
  401.  
  402. : ABORT"        ( -- )   COMPILE (ABORT") X," ;   IMMEDIATE
  403. : ABORT         ( -- )   TRUE ABORT" "  ;
  404.  
  405. : FORGET        ( -- )
  406.                 BL WORD ?UPPERCASE DUP CURRENT @ HASH @
  407.                 (FIND) 0= ?MISSING DUP >VIEW (FRGET) ;
  408.  
  409. : ?CONDITION    ( f -- )        NOT ABORT" Conditionals Wrong"   ;
  410.  
  411. : >MARK         ( -- addr )     XHERE NIP 0 X,   ;
  412. : >RESOLVE      ( addr -- )     XHERE -ROT SWAP !L   ;
  413. : <MARK         ( -- addr )     XHERE NIP ;
  414. : <RESOLVE      ( addr -- )     X, ;
  415.  
  416. : ?>MARK        ( -- f addr )   TRUE >MARK   ;
  417. : ?>RESOLVE     ( f addr -- )   SWAP ?CONDITION >RESOLVE  ;
  418. : ?<MARK        ( -- f addr )   TRUE   <MARK   ;
  419. : ?<RESOLVE     ( f addr -- )   SWAP ?CONDITION <RESOLVE  ;
  420.  
  421. comment:
  422.         LEAVE and ?LEAVE could be non-immediate in this system, but the 83
  423.         standard specifies an immediate LEAVE, so they  both are for
  424.         uniformity.
  425. comment;
  426.  
  427. : LEAVE         COMPILE (LEAVE)                                 ; IMMEDIATE
  428. : ?LEAVE        COMPILE (?LEAVE)                                ; IMMEDIATE
  429.  
  430. comment:
  431.         BEGIN, THEN, DO ?DO, LOOP, +LOOP, UNTIL, AGAIN, REPEAT, IF ELSE,
  432.         WHILE: These are the compiling words needed to properly compilethe
  433.         Forth Conditional Structures. Each of them is immediate and they
  434.         must compile their runtime routines along withwhatever addresses
  435.         they need. A modest amount of errorchecking is done. If you want to
  436.         rip out the error checking change the ?> and ?< words to > and <
  437.         words, andall of the 2DUPs to DUPs and the 2SWAPs to SWAPs. The
  438.         rest should stay the same.
  439.  
  440.         DOAGAIN, DOTHEN, DOBEGIN, ?UNTIL & ?WHILE are words that are NOOPs
  441.         , or equivalant to ?BRANCH. They are provided to make it easier for
  442.         the Decompiler to know where the control structures start and end.
  443.   comment;
  444.  
  445. : BEGIN         COMPILE DOBEGIN ?<MARK                          ; IMMEDIATE
  446. : THEN          COMPILE DOTHEN ?>RESOLVE                        ; IMMEDIATE
  447. : DO            COMPILE (DO)   ?>MARK                           ; IMMEDIATE
  448. : ?DO           COMPILE (?DO)  ?>MARK                           ; IMMEDIATE
  449. : LOOP          COMPILE (LOOP)  2DUP 2+ ?<RESOLVE ?>RESOLVE     ; IMMEDIATE
  450. : +LOOP         COMPILE (+LOOP) 2DUP 2+ ?<RESOLVE ?>RESOLVE     ; IMMEDIATE
  451. : UNTIL         COMPILE ?UNTIL     ?<RESOLVE                    ; IMMEDIATE
  452. : AGAIN         COMPILE  DOAGAIN   ?<RESOLVE                    ; IMMEDIATE
  453. : REPEAT        2SWAP COMPILE DOREPEAT ?<RESOLVE ?>RESOLVE      ; IMMEDIATE
  454. : IF            COMPILE  ?BRANCH  ?>MARK                        ; IMMEDIATE
  455. : ELSE          COMPILE  BRANCH ?>MARK  2SWAP ?>RESOLVE         ; IMMEDIATE
  456. : WHILE         COMPILE ?WHILE ?>MARK                           ; IMMEDIATE
  457.  
  458. : ,VIEW         ( -- )  LOADLINE @ Y, ;
  459.  
  460. : NOHEADROOM    ( --- )
  461.                 TRUE ABORT" Out of HEAD memory!" ;
  462.  
  463. : NOLISTROOM    ( --- )
  464.                 TRUE ABORT" Out of LIST memory!" ;
  465.  
  466. CODE SPCHECK    ( --- F1 F2 )           \ HEAD AND LIST SPACE CHECK
  467.                 MOV AX, YDP             \ get head DP
  468.                 SHR AX, # 1             \ convert to ssegment
  469.                 SHR AX, # 1
  470.                 SHR AX, # 1
  471.                 SHR AX, # 1
  472.                 ADD AX, # 6             \ add 6 segments for headroom
  473.                 CMP AX, ' #HEADSEGS >BODY \ are we out of space yet
  474.              >  IF      MOV AX, # ' NOHEADROOM
  475.                         JMP AX
  476.                 THEN
  477.                 MOV AX, XDPSEG          \ load up LIST segment
  478.                 SUB AX, XSEG            \ convert to size of list so far
  479.                 ADD AX, # 6             \ add 6 for headroom
  480.                 CMP AX, ' #LISTSEGS >BODY \ are we out of space yet
  481.              >  IF      MOV AX, # ' NOLISTROOM
  482.                         JMP AX
  483.                 THEN
  484.                 NEXT
  485.                 END-CODE
  486.  
  487. : "HEADER       ( STR --- )
  488.                 SPCHECK
  489.                 WARNING @  IF DUP FIND NIP IF
  490.                 DUP  CR  COUNT TYPE ."  isn't unique " THEN  THEN ( str )
  491.                 ALIGN  YHERE 2- Y@ CNHASH  HERE CNHASH  <>
  492.                 IF      YHERE HERE CNHASH DUP Y@ ROT MIN SWAP
  493.                         Y! ( >NAME hash entry )
  494.                 THEN    ,VIEW
  495.                 YHERE OVER CURRENT @ HASH DUP @  Y,  ( link  ) ! ( current )
  496.                 YHERE LAST ! ( remember nfa )
  497.                 YHERE ?CS: ROT  DUP C@  WIDTH @  MIN 1+ >R  ( yh cs str )
  498.                 YHERE YS: R@ CMOVEL ( copy str ) R> YDP +! ALIGN ( nam )
  499.                 128 SWAP YCSET   128 YHERE 1- YCSET   ( delimiter Bits )
  500.                 HERE Y, ( CFA in header )
  501.                 YHERE HERE CNHASH 2+ Y! ( valid stopper in next n hash entry)
  502.                 ;
  503.  
  504. : ,CALL         232 C, 0 HERE 2+ - , ;        \ Compiles addr 0000 !!!!
  505. : ,JUMP         233 C, 0 HERE 2+ - , ;
  506.  
  507. : <HEADER>      ( | name --- )
  508.                 BL WORD ?UPPERCASE "HEADER ;
  509.  
  510. DEFER HEADER    ' <HEADER> IS HEADER
  511.  
  512. : CREATE        ( | name -- )  HEADER ,CALL ;USES >NEXT ,-X
  513.  
  514. : !CSP          ( -- )  SP@ CSP !   ;
  515.  
  516. : ?CSP          ( -- )  SP@ CSP @ <> ABORT" Stack Changed"   ;
  517.  
  518. : HIDE          ( -- )  LAST @ DUP N>LINK Y@ SWAP CURRENT @ YHASH ! ;
  519.  
  520. : REVEAL        ( -- )  LAST @ DUP N>LINK    SWAP CURRENT @ YHASH ! ;
  521.  
  522. : (;USES)       ( -- )
  523.                 2R> @L LAST @ NAME> dup>r 3 + - R> 1+ ! ;
  524.  
  525. : (;CODE)       ( -- )
  526.                 2R> @L LAST @ NAME>
  527.                 dup>r 232 ( CALL ) R@ C!       \ Make a CALL not JUMP
  528.                 3 + - R> 1+ !  ;
  529.  
  530. : DOES>         ( -- )
  531.                 COMPILE (;CODE) HERE X, 232 ( CALL ) C,
  532.                 [ [FORTH] ASSEMBLER DODOES META ] LITERAL
  533.                 HERE 2+ - , XHERE PARAGRAPH + DUP XDPSEG !
  534.                 XSEG @ - , XDP OFF ; IMMEDIATE
  535.  
  536. VOCABULARY ASSEMBLER
  537.  
  538. DEFER SETASSEM  \ Setup for assembly stuff to follow
  539.  
  540. ' NOOP IS SETASSEM
  541.  
  542. : [             ( -- )  STATE OFF   ;   IMMEDIATE
  543.  
  544. : ;USES         ( -- )  ?CSP   COMPILE  (;USES)
  545.                 [COMPILE] [   REVEAL   ASSEMBLER   ; IMMEDIATE
  546.  
  547. : ;CODE         ( -- )  ?CSP   COMPILE  (;CODE) HERE X,
  548.                 [COMPILE] [   REVEAL   SETASSEM ; IMMEDIATE
  549.  
  550. : (])           ( -- )
  551.                 STATE ON
  552.         BEGIN   ?STACK   DEFINED DUP
  553.                 IF      0> IF    EXECUTE   ELSE   X,   THEN
  554.                 ELSE   DROP   NUMBER  DOUBLE?
  555.                         IF          [COMPILE] DLITERAL
  556.                         ELSE DROP   [COMPILE] LITERAL   THEN
  557.                 THEN   TRUE DONE?
  558.         UNTIL   ;
  559.  
  560. DEFER ]         ' (]) IS ]
  561.  
  562. : MAKEDUMMY     ( NAME --- )
  563.                 HEADER ,JUMP
  564.                 XHERE PARAGRAPH +       \ absolute paragraph of new def
  565.                 DUP XDPSEG !            \ set new XHERE segment
  566.                 XSEG @ - ,              \ compile relative paragraph of def
  567.                 XDP OFF
  568.                 COMPILE UNNEST
  569.                 ;USES  NEST ,-X
  570.  
  571. : ANEW          ( NAME --- )
  572.                 >IN @ >R DEFINED NIP  R@ >IN !
  573.                 IF      FORGET
  574.                 THEN    R> >IN !  MAKEDUMMY   ;
  575.                                                         \ Add if needed
  576. : (:)           ( -- )
  577.                 !CSP   CURRENT @ CONTEXT !
  578.                 HEADER ,JUMP
  579.                 XHERE PARAGRAPH +
  580.                 DUP XDPSEG !
  581.                 XSEG @ - ,
  582.                 XDP OFF
  583.                 HIDE
  584.                 ;USES   NEST ,-X
  585.  
  586. : :             ( --- )
  587.                 (:) ] ;
  588.  
  589. : ;             ( -- )
  590.                 STATE @ 0= ABORT" Not Compiling!"
  591.                 ?CSP   COMPILE UNNEST   REVEAL   [COMPILE] [  ; IMMEDIATE
  592.  
  593. : RECURSIVE     ( -- )  REVEAL ;   IMMEDIATE
  594.  
  595. : CONSTANT      ( n -- ) CREATE ,     ;USES DOCONSTANT ,-X
  596.  
  597. : VALUE         ( n -- ) CREATE ,     ;USES DOVALUE    ,-X
  598.  
  599. : VARIABLE      ( -- )   CREATE 0 ,   ;USES >NEXT ,-X
  600.                                         \ not really needed, but pretty.
  601.  
  602. : DEFER         ( -- )
  603.                 CREATE   ['] CRASH ,  ;USES   DODEFER  ,-X
  604.  
  605. DODEFER RESOLVES <DEFER>
  606.  
  607. : VOCABULARY    ( -- )  CREATE   #THREADS 0 DO   0 ,  LOOP
  608.                         HERE  VOC-LINK @ ,  VOC-LINK !
  609.                         DOES> CONTEXT !  ;
  610.  
  611.  RESOLVES <VOCABULARY>
  612.  
  613. : DEFINITIONS   ( -- ) CONTEXT @ CURRENT !   ;
  614.  
  615. : 2CONSTANT     CREATE   , ,    ( d# -- )
  616.                 DOES> 2@   ;    ( -- d# )   DROP
  617.  
  618. : 2VARIABLE     0 0 2CONSTANT   ( -- )
  619.                 DOES> ;         ( -- addr )   DROP
  620.  
  621. : <RUN>         ( -- )
  622.         STATE @ IF      ]
  623.                         STATE @ NOT
  624.                         IF   INTERPRET   THEN
  625.                 ELSE    INTERPRET   THEN   ;
  626.  
  627. DEFER RUN       ' <RUN> IS RUN
  628.  
  629. : (?ERROR)      ( adr len f -- )
  630.                 IF      ['] <RUN> IS RUN
  631.                         2>R SP0 @ SP!   PRINTING OFF
  632.                         2R> SPACE TYPE SPACE   QUIT
  633.                 ELSE    2DROP  THEN  ;
  634.  
  635. ' (?ERROR) IS ?ERROR
  636.  
  637.